home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / win.tcl < prev   
Encoding:
Text File  |  2001-01-22  |  14.0 KB  |  514 lines
  1. ## -*-Tcl-*- (install) (nowrap)
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  #  
  5.  #  Chuck's Additions - an Alpha hack
  6.  #
  7.  #  FILE: "win.tcl"
  8.  #                      created: 4/6/98
  9.  #                    last update: 01/22/2001 {23:31:40 PM}
  10.  #  Author: Chuck Gregory
  11.  #  E-mail: <cgregory@mail.arc.nasa.gov>
  12.  #    mail: Logicon
  13.  #          NASA Ames Research Center, Moffett Field, CA  94035
  14.  #
  15.  #  Description:
  16.  #
  17.  #    Window handling routines. All procs are bound in AlphaBits.tcl.
  18.  #      Recommend the following global interface preference settings:
  19.  #
  20.  #                    MacOS 8.0     MacOS < 8
  21.  #          defLeft         6             0
  22.  #          defTop        41            38
  23.  #          defWidth           510           510
  24.  #          horMargin             6             2
  25.  #          tileHeight         [707]           426
  26.  #          tileLeft             6             0
  27.  #          tileMargin        22            20
  28.  #          tileTop            41            38
  29.  #          tileWidth        [1014]           640
  30.  #
  31.  #  History:
  32.  #
  33.  #  modified  by   rev  reason
  34.  #  --------  ---  ---  -----------
  35.  #  04/06/98        7.1b6 original
  36.  #  04/08/98  czg  1.0  modified for MacOS 8
  37.  #  07/15/98  VMD    removed lisp'ish functions
  38.  #  07/21/98  czg  1.1  fixed margin bugs in shrinkLeft & shrinkRight;
  39.  #            documented prefs recommendations
  40.  # ###################################################################
  41.  ##
  42.  
  43. proc shrinkHigh {} {
  44.     global numWinsToTile tileTop tileHeight tileMargin
  45.     set names [winNames -f]
  46.     set numWins [llength $names]
  47.     if {$numWins<2} {set numWins 2}
  48.     if {$numWins>$numWinsToTile} {set numWins $numWinsToTile}
  49.     set width [lindex [getGeometry] 2]
  50.     set height [expr {($tileHeight - $tileMargin) / $numWins}]
  51.     set text [getGeometry]
  52.     set left [lindex $text 0]
  53.     sizeWin $width $height
  54.     moveWin $left $tileTop
  55. }
  56.  
  57. proc shrinkLow {} {
  58.     global numWinsToTile tileTop tileHeight tileMargin
  59.     set names [winNames -f]
  60.     set numWins [llength $names]
  61.     if {$numWins<2} {set numWins 2}
  62.     if {$numWins>$numWinsToTile} {set numWins $numWinsToTile}
  63.     set width [lindex [getGeometry] 2]
  64.     set height [expr {($tileHeight - $tileMargin) / $numWins}]
  65.     set text [getGeometry]
  66.     set left [lindex $text 0]
  67.     sizeWin $width $height
  68.     moveWin $left [expr {$tileTop + $height + $tileMargin}]
  69. }
  70.  
  71. proc singlePage {} {shrinkFull}
  72. proc defaultSize {} {shrinkFull}
  73.  
  74. proc shrinkFull {} {
  75.     global tileTop tileHeight tileLeft defWidth
  76.     moveWin $tileLeft $tileTop
  77.     sizeWin $defWidth $tileHeight
  78. }
  79.  
  80. proc shrinkLeft {} {
  81.     global horMargin tileWidth tileLeft
  82.     set width [expr {($tileWidth-$horMargin)/2}]
  83.     set height [lindex [getGeometry] 3]
  84.     set text [getGeometry]
  85.     set top [lindex $text 1]
  86.     moveWin $tileLeft $top
  87.     sizeWin $width $height
  88. }
  89.  
  90. proc shrinkRight {} {
  91.     global horMargin tileWidth tileLeft
  92.     set width [expr {($tileWidth-$horMargin)/2}]
  93.     set height [lindex [getGeometry] 3]
  94.     set text [getGeometry]
  95.     set top [lindex $text 1]
  96.     moveWin [expr {$tileLeft + $width + $horMargin}] $top
  97.     sizeWin $width $height
  98. }
  99.  
  100. proc swapWithNext {} {
  101.     set files [winNames]
  102.     if {[llength $files] < 2} return
  103.     bringToFront [lindex $files 1]
  104. }
  105.     
  106.  
  107.  
  108. proc nextWindow {} {
  109.     global win::Active 
  110.     set files [winNames -f]
  111.     if {[llength $files] < 2} {return}
  112.     set f [lindex $files 0]
  113.     if {[info tclversion] < 8.0} {
  114.     regsub -all {[][]} $f {\\\0} f
  115.     }
  116.     set aind [lsearch -exact ${win::Active} $f]
  117.     if {$aind < 0} {error "No win '$f'"}
  118.     set rng [lrange ${win::Active} 0 [expr {$aind-1}]]
  119.     set win::Active [concat [lrange ${win::Active} $aind end] $rng]
  120.     set win::Active [lrange ${win::Active} 1 end]
  121.     lappend win::Active $f
  122.     if {[info tclversion] < 8.0} {
  123.     regsub -all {\\([][])} [lindex ${win::Active} 0] {\1} w
  124.     } else {
  125.     set w [lindex ${win::Active} 0]
  126.     }
  127.     bringToFront $w
  128. }
  129.  
  130.  
  131. proc prevWindow {} {
  132.     global win::Active 
  133.     set files [winNames -f]
  134.     if {[llength $files] < 2} {return}
  135.     set f [lindex $files 0]
  136.     regsub -all {[][]} $f {\\\0} f
  137.     set aind [lsearch -exact ${win::Active} $f]
  138.     if {$aind < 0} {error "No win '$f'"}
  139.     set rng [lrange ${win::Active} 0 [expr {$aind-1}]]
  140.     set win::Active [concat [lrange ${win::Active} $aind end] $rng]
  141.     set f2 [lindex [lrange ${win::Active} end end] 0]
  142.     set win::Active [lreplace ${win::Active} end end]
  143.     set win::Active [linsert ${win::Active} 0 $f2]
  144.     regsub -all {\\([][])} $f2 {\1} f2
  145.     bringToFront $f2
  146. }
  147.  
  148. proc bufferOtherWindow {} {
  149.     global tileHeight tileTop tileWidth tileMargin
  150.     global numWinsToTile
  151.     set margin $tileMargin
  152.     set win [win::Current]
  153.     set numWins 2
  154.     set hor 2
  155.     set height [expr {($tileHeight/$numWins)-$margin}]
  156.     set height [expr {$height + $margin / $numWins}]
  157.     set width $tileWidth
  158.     set ver $tileTop
  159.     
  160.     if {[llength [winNames]] < 2} {message "No other window!"; return}
  161.     set res [prompt::fromChoices "Window other half" [nextWin] -command winNames]
  162.     
  163.     set geo [getGeometry]
  164.     if {([lindex $geo 2] != $width) || ([lindex $geo 3] != $height) || ([lindex $geo 0] != $hor) || (([lindex $geo 1] != $ver) && ([lindex $geo 1] != [expr {$ver + $height + $margin}]))} {
  165.     moveWin $win 1000 0
  166.     sizeWin $win $width $height
  167.     moveWin $win $hor $ver
  168.     incr ver [expr {$height + $margin}]
  169.     } else {
  170.     if {[lindex $geo 1] == $ver} {
  171.         incr ver [expr {$height + $margin}]
  172.     } 
  173.     }
  174.     
  175.     set geo [getGeometry $res]
  176.     if {([lindex $geo 0] != $hor) || ([lindex $geo 1] != $ver) || ([lindex $geo 2] != $width) || ([lindex $geo 3] != $height)} {
  177.     moveWin $res 1000 0
  178.     sizeWin $res $width $height
  179.     moveWin $res $hor $ver
  180.     }
  181.     bringToFront $res
  182. }
  183.  
  184.         
  185.     
  186.         
  187.  
  188. proc winvertically {} {
  189.     global tileHeight tileTop tileWidth tileMargin
  190.     global numWinsToTile defWidth tileLeft
  191.     set margin $tileMargin
  192.     set names [winNames -f]
  193.     set numWins [llength $names]
  194.     if {$numWins<=1} return
  195.     if {$numWins>$numWinsToTile} {set numWins $numWinsToTile}
  196.     if {$numWins == 0} {return}
  197.     set height [expr {($tileHeight/$numWins)-$margin}]
  198.     set height [expr {$height + $margin / $numWins}]
  199.     set width $defWidth
  200.     set ver $tileTop
  201.     for {set i 0} {$i < $numWins} {incr i} {
  202.     sizeWin [lindex $names $i] $width $height
  203.     moveWin [lindex $names $i] $tileLeft $ver
  204.     set ver [expr {$ver+$margin+$height}]
  205.     }
  206. }
  207.  
  208. proc winhorizontally {} {
  209.     global tileHeight tileLeft tileWidth tileTop numWinsToTile horMargin
  210.     set names [winNames -f]
  211.     set numWins [llength $names]
  212.     if {$numWins<=1} return
  213.     if {$numWins>$numWinsToTile} {set numWins $numWinsToTile}
  214.     if {$numWins == 0} {return}
  215.     set width [expr {($tileWidth/$numWins)-$horMargin}]
  216.     set width [expr {$width + $horMargin / $numWins}]
  217.     set height $tileHeight
  218.     set hor $tileLeft
  219.     for {set i 0} {$i < $numWins} {incr i} {
  220.     sizeWin [lindex $names $i] $width $height
  221.     moveWin [lindex $names $i] $hor $tileTop
  222.     set hor [expr {$hor+$width+$horMargin}]
  223.     }
  224. }
  225.  
  226.  
  227. proc winunequalHor {} {
  228.     global tileLeft tileHeight tileWidth tileTop numWinsToTile horMargin
  229.     global tileProportion
  230.     set names [winNames -f]
  231.     sizeWin [lindex $names 0] \
  232.       [expr {$tileProportion*$tileWidth - $horMargin/2}] $tileHeight
  233.     moveWin [lindex $names 0] $tileLeft $tileTop
  234.     sizeWin [lindex $names 1] \
  235.       [expr {(1-$tileProportion)*$tileWidth - $horMargin/2}] $tileHeight
  236.     moveWin [lindex $names 1] \
  237.       [expr {$tileLeft + $tileProportion*$tileWidth + $horMargin/2}] $tileTop
  238. }
  239.  
  240.  
  241. proc winunequalVert {} {
  242.     global tileLeft tileMargin tileHeight tileWidth tileTop numWinsToTile
  243.     global horMargin tileProportion defWidth
  244.     set names [winNames -f]
  245.     set height [expr {$tileHeight + $tileMargin}]
  246.     sizeWin [lindex $names 0] \
  247.       $defWidth [expr {$tileProportion*$height - $tileMargin}]
  248.     moveWin [lindex $names 0] $tileLeft $tileTop
  249.     sizeWin [lindex $names 1] \
  250.       $defWidth [expr {(1-$tileProportion)*$height - $tileMargin}]
  251.     moveWin [lindex $names 1] \
  252.       $tileLeft [expr {$tileTop + $tileProportion*$height}]
  253. }
  254.  
  255.  
  256. proc wintiled {} {
  257.     global tileHeight tileWidth numWinsToTile tileTop
  258.     set xPan 8
  259.     set yPan 10
  260.     set xMarg 2
  261.     set yMarg $tileTop
  262.     set yMax 50
  263.     set names [winNames -f]
  264.     set numWins [llength $names]
  265.     if {$numWins<1} return
  266.     set line 0    
  267.     set height [expr {$tileHeight-$yPan*($numWins-1)}]
  268.     set width [expr {$tileWidth-$xPan*($numWins-1)}]
  269.     
  270.     for {set i 0} {$i < $numWins} {incr i} {
  271.     moveWin [lindex $names $i] [expr {$xMarg+$i*$xPan}] [expr {$yMarg+$line}]
  272.     set line [expr {$line+$yPan}]
  273.     if {$line>$yMax} {set line 0}
  274.     sizeWin [lindex $names $i] $width $height
  275.     }
  276. }
  277.  
  278.  
  279. proc winoverlay {} {
  280.     global defHeight defWidth numWinsToTile tileTop
  281.     set names [winNames -f]
  282.     set numWins [llength $names]
  283.     if {$numWins<1} return
  284.     for {set i 0} {$i < $numWins} {incr i} {
  285.     moveWin [lindex $names $i] 2 $tileTop
  286.     sizeWin [lindex $names $i] $defWidth $defHeight
  287.     }
  288. }
  289.  
  290. proc chooseAWindow {} {
  291.     switch -- [llength [winNames -f]] {
  292.     0 {
  293.         message "No window!"; return
  294.     }
  295.     1 {
  296.         message "No other window!"; return
  297.     }
  298.     default {
  299.         set name [prompt::fromChoices "Window" [nextWin] \
  300.           -command "lsort -ignore \[winNames\]"]
  301.         if {[string length $name]} {
  302.         bringToFront $name
  303.         if {[icon -q]} { icon -f $name -o }
  304.         }
  305.     }
  306.     }
  307. }
  308.  
  309. proc closeAWindow {} {
  310.     if {![llength [winNames]]} {message "No window!"; return}
  311.     set name [prompt::fromChoices "Close window" [win::CurrentTail] \
  312.       -command "lsort -ignore \[winNames\]"]
  313.     catch {bringToFront $name; killWindow}
  314. }
  315.  
  316. proc nextWin {} {
  317.     global win::Active 
  318.     set files [winNames -f]
  319.     if {[llength $files] < 2} {return ""}
  320.     set f [lindex $files 0]
  321.     set aind [lsearch -exact ${win::Active} $f]
  322.     if {$aind < 0} {error "No win '$f'"}
  323.     if {[incr aind] < [llength ${win::Active}]} {
  324.     return [file tail [lindex ${win::Active} $aind]]
  325.     } else {
  326.     return [file tail [lindex ${win::Active} 0]]
  327.     }
  328. }
  329.  
  330. proc iconify {} { 
  331.     icon -t 
  332.     if {[icon -q]} {
  333.     nextWindow
  334.     }
  335. }
  336.  
  337. proc zoom {} {
  338.     global nzmState tileHeight tileWidth zoomedGeo tileTop tileLeft
  339.     
  340.     set win [win::Current]
  341.     if {[info exists nzmState($win)]} {
  342.     if {[getGeometry] == $zoomedGeo} {
  343.         set state $nzmState($win)
  344.         moveWin [lindex $state 0] [lindex $state 1]
  345.         sizeWin [lindex $state 2] [lindex $state 3]
  346.         unset nzmState($win)
  347.         return
  348.     }
  349.     } 
  350.     
  351.     set nzmState($win) [getGeometry]
  352.     moveWin $tileLeft $tileTop
  353.     sizeWin $tileWidth $tileHeight
  354.     
  355.     if {![info exists zoomedGeo]} {
  356.     set zoomedGeo [getGeometry]
  357.     }
  358. }
  359.  
  360. #================================================================================
  361.  
  362. proc otherThing {} {
  363.     set win [win::Current]
  364.     getWinInfo -w $win arr
  365.     if {$arr(split)} {
  366.     otherPane
  367.     } else {
  368.     swapWithNext
  369.     }
  370. }
  371.  
  372. proc winAttribute {att {win {}}} {
  373.     if {![string length $win]} {
  374.     set win [win::Current]
  375.     }
  376.     getWinInfo -w $win arr
  377.     return $arr($att)
  378. }
  379.  
  380. proc floatName {str} {
  381.     if {[string match "•*" $str]} {
  382.     foreach n [info globals {*Menu}] {
  383.         global $n
  384.         if {![catch {set $n}] && ([set $n] == $str)} {
  385.         regexp {(.*)Menu} $n dummy name
  386.         return "[string toupper [string index $name 0]][string range $name 1 end]"
  387.         }
  388.     }
  389.     }
  390.     return "[string toupper [string index $str 0]][string range $str 1 end]"
  391. }
  392. proc winDirty {} {
  393.     getWinInfo arr
  394.     return $arr(dirty)
  395. }
  396.  
  397. proc winReadOnly {{win ""}} {
  398.     goto [minPos]
  399.     if {$win == ""} {set win [win::Current]}
  400.     setWinInfo -w $win dirty 0
  401.     setWinInfo -w $win read-only 1
  402. }
  403.  
  404. proc shrinkWindow {{shrinkWidth 0}} {
  405.     global defHeight defWidth
  406.     # These constants work for 9-pt Monaco type
  407.     set lineht 11
  408.     set htoff 22
  409.     set chwd 6
  410.     set choff 20
  411.     
  412.     set wd [lindex [getGeometry] 2]
  413.     set ht [lindex [getGeometry] 3]
  414.     set top [lindex [getGeometry] 1]
  415.     set left [lindex [getGeometry] 0]
  416.     
  417.     set mxht [expr {[lindex [getMainDevice] 3] - $top - 5 -15}]
  418.     set mxwd [expr {[lindex [getMainDevice] 2] - $left - 5}]
  419.     set mnht 120
  420.     set mnwd 200
  421.     
  422.     set htWd [fileHtWd $shrinkWidth]
  423.     set lines [lindex $htWd 0]
  424.     set chars [lindex $htWd 1]
  425.     
  426.     if {$lines <= 1} {set lines 10}
  427.     
  428.     
  429.     if {$lines > 0} {
  430.     set ht [expr {$htoff + ( $lineht * (1 + $lines)) }]
  431.     } elseif {$ht > $defHeight} {
  432.     set ht $defHeight
  433.     }
  434.     
  435.     if {$chars > 0} {
  436.     set wd [expr {$choff + ( $chwd * (2 + $chars)) }]
  437.     } elseif {$wd > $defWidth} {
  438.     set wd $defWidth
  439.     }
  440.     
  441.     if {$ht > $mxht} {set ht $mxht}
  442.     if {$wd > $mxwd} {set wd $mxwd}
  443.     if {$ht < $mnht} {set ht $mnht}
  444.     if {$wd < $mnwd} {set wd $mnwd}
  445.     sizeWin $wd $ht
  446. }
  447.  
  448. #############################################################################
  449. # Return the number of lines and the maximum number of characters in any 
  450. # line of a file.  It would be nice if there was a built-in command to
  451. # do this (i.e., compiled C code) because this is a pretty slow way to
  452. # get the maximum line width.
  453.  
  454. proc fileHtWd {{checkWidth 0}} {
  455.     set text [getText [minPos] [maxPos]] 
  456.     getWinInfo arr
  457.     set tabw [expr {$arr(tabsize) - 1}]
  458.     
  459.     set lines [split $text "\r\n"]
  460.     set nlines [llength $lines]
  461.     
  462.     if {$checkWidth > 1} {
  463.     set lines [eval lrange \$lines [displayedLines]]
  464.     }
  465.     
  466.     set llen 0
  467.     if {$checkWidth > 0} {
  468.     foreach line $lines {
  469.         regsub {                +∞.*$} $line {} line
  470.         regsub {    } $line {    } line
  471.         set len [string length $line]
  472.         if {[set ntab [llength [split $line "\t"]]] > 1} {
  473.         set len [expr {$len + $tabw*($ntab-1)}]
  474.         }
  475.         if { $len > $llen} {
  476.         set llen $len
  477.         }
  478.     }
  479.     }
  480.     #    alertnote "Text Height : $nlines ; Text Width : $llen "
  481.     return [list $nlines $llen]
  482. }
  483.  
  484. # Report what range of lines are displayed in any window.
  485. # (A side effect is that the insertion point is moved to the 
  486. # top of the window, if it was previously off-screen)
  487. #
  488. proc displayedLines {{window {}}} {
  489.     if {$window == {}} { set window [win::Current] }
  490.     
  491.     bringToFront $window
  492.     set oldPos [getPos]
  493.     moveInsertionHere
  494.     set top [getPos]
  495.     set first [lindex [posToRowCol $top] 0]
  496.     moveInsertionHere -last
  497.     set bottom [getPos]
  498.     set last [lindex [posToRowCol $bottom] 0]
  499.     
  500.     if {[pos::compare $oldPos < $top] || [pos::compare $oldPos > $bottom]} {
  501.     goto $top
  502.     } else {
  503.     goto $oldPos
  504.     }
  505.     
  506.     return [list $first $last]
  507. }
  508.  
  509.  
  510.  
  511.  
  512.  
  513.  
  514.